Delphi Developer's Kit 1996/Delphi Developer's Kit 1996.iso/power/handles/handles.pas

Pascal/Delphi Source File | 1995-12-22 | 24.4 KB | 771 lines

unit Handles;

{ A first attempt at a StretchHandle component for Delphi... it "owns"
  another component via the FChildControl property, and will resize or
  move its Child along with itself when it is dragged or stretched at
  runtime with the left mouse button. The component is sized 2 pixels
  larger on each side than its FChildControl, and the grab handles are
  5x5.  It will shrink to 5x5.

  Any suggestions for improvement would be appreciated...

  Revised 7/1/95: Used MouseUp, MouseDown, MouseMove override rather than
                  message handlers for mouse events.

                  Changed name of EControlInvalid to EBadChild (sorry!).

                  Added Child property (read/write, equivalent to using
                  Attach/Detach methods).

                  Fixed bug in IsAttached.

                  Added BringToFront & SendToBack methods to correctly
                  manipulate ChildControl

                  Added arrow keys to move a selected control in one-pixel
                  increments.

                  Added a secondary color for selection of multiple Child
                  controls.

                  Added logic to move siblings (other selected objects on
                  the same Parent) when a selected object is moved.

                  Eliminated TOverlay mechanism for rubberbanding; now using
                  WINAPI calls with GetDC(0).

                  Added a Lock property to disable move/resize.

                  Started adding a snap-to grid mechanism (GridX, GridY & SnapToGrid
                  properties); needs more work, though.

  Anthony Scott
  CIS: 75567,3547                                                           }

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Menus, StdCtrls;
                                       { miscellaneous type declarations }
type
  TDragStyle = (dsMove, dsSizeTopLeft, dsSizeTopRight, dsSizeBottomLeft, dsSizeBottomRight,
                dsSizeTop, dsSizeLeft, dsSizeBottom, dsSizeRight);
  EBadChild = class(Exception);
                                       { TStretchHandle component declaration }
type
  GridValues = 1..100;

  TStretchHandle = class(TCustomControl)
  private
    FDragOffset: TPoint;
    FDragStyle: TDragStyle;
    FDragging: boolean;
    FDragRect: TRect;
    FLocked: boolean;
    FColor: TColor;
    FPrimaryColor: TColor;
    FSecondaryColor: TColor;
    FGridX, FGridY: GridValues;
    FChildControl: TControl;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMGetDLGCode(var Message: TMessage); message WM_GETDLGCODE;
    procedure SetChildControl(ChildControl: TControl);
    procedure MoveSiblings(XOffset, YOffset: integer);
    procedure Rubberband(NewRect: TRect);
    function HasSiblings: boolean;
    function GetChildControl: TControl;
    function GetModifiedRect(XPos, YPos: integer): TRect;
  protected
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure KeyDown(var key: Word; Shift: TShiftState); override;
    procedure Paint; override;
    property Canvas;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure BringToFront;
    procedure SendToBack;
    procedure Attach(ChildControl: TControl);
    procedure Detach;
    procedure SetColors(Color1, Color2: TColor);
    procedure SwitchColor;
    procedure SetGridState(Value: boolean);
    function GetGridState: boolean;
    function IsAttached: boolean;
                                       { new run-time only properties }
    property Child: TControl read GetChildControl write SetChildControl;
    property Attached: boolean read IsAttached;
  published
                                       { new properties }
    property Color: TColor read FPrimaryColor write FPrimaryColor default clBlack;
    property SecondaryColor: TColor read FSecondaryColor write FSecondaryColor default clGray;
    property Locked: boolean read FLocked write FLocked default False;
    property GridX: GridValues read FGridX write FGridX default 8;
    property GridY: GridValues read FGridY write FGridY default 8;
    property SnapToGrid: boolean read GetGridState write SetGridState default False;
                                       { inherited properties }
    property DragCursor;
    property Enabled;
    property Hint;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
                                       { defined events }
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnKeyDown;
    property OnKeyPress;
  end;

procedure Register;

implementation

procedure Register;
begin
                                       { add the component to the 'Samples' tab }
  RegisterComponents('Samples', [TStretchHandle]);

end;

constructor TStretchHandle.Create(AOwner: TComponent);
var
  i: integer;
  Found: boolean;
begin

  inherited Create(AOwner);
                                       { initialize default properties }
  Width := 24;
  Height := 24;
  FChildControl := nil;
  FPrimaryColor := clBlack;
  FSecondaryColor := clGray;
                                       { a value of 1 is used to turn off the snap-to grid }
  FGridX := 1;
  FGridY := 1;
                                       { doesn't do anything until it is Attached to something else }
  Enabled := False;
  Visible := False;

  Found := False;

end;

destructor TStretchHandle.Destroy;
begin

  inherited Destroy;

end;

procedure TStretchHandle.CreateParams(var Params: TCreateParams);
begin
                                       { set default Params values }
  inherited CreateParams(Params);
                                       { then add transparency }
  Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT;

end;

procedure TStretchHandle.Attach(ChildControl: TControl);
var
  i: integer;
begin
                                       { definitely not allowed! }
  if ChildControl is TForm then
    raise EBadChild.Create('Handles can not be attached to this component');
                                       { auto-detach if still attached (bad dog!); also detaches if Child = nil }
  if Attached then
    Detach;

  if (ChildControl <> nil) then
    begin
                                       { allows StretchHandle to manage the child control's size & position }
      FChildControl := ChildControl;
                                       { honour the lineage }
      Parent := ChildControl.Parent;
      SetBounds(ChildControl.Left - 2, ChildControl.Top - 2, ChildControl.Width + 5, ChildControl.Height + 5);
                                       { look for siblings, set up secondary colors if any found }
      FColor := FPrimaryColor;
      for i := 0 to Parent.ControlCount - 1 do
        if Parent.Controls[i] is TStretchHandle then
          begin
            if (TStretchHandle(Parent.Controls[i]).Attached) and (TStretchHandle(Parent.Controls[i]) <> Self) then
              begin
                FColor := FSecondaryColor;
                TStretchHandle(Parent.Controls[i]).SwitchColor;
              end;
          end;
                                       { only make it visible now, to avoid color flashing, & accept events }
      FDragRect := Rect(0, 0, 0, 0);
      Enabled := True;
      Visible := True;
                                       { use old BringToFront so as not to change Child's Z-order }
      if not (csDesigning in ComponentState) then
        begin
          inherited BringToFront;
          SetFocus;
        end;

    end;

end;

procedure TStretchHandle.Detach;
begin
                                       { disable & hide StretchHandle }
  FChildControl := nil;
  FLocked := False;
  Enabled := False;
  Visible := False;
  Parent := nil;
  FDragRect := Rect(0, 0, 0, 0);

end;

procedure TStretchHandle.SetColors(Color1, Color2: TColor);
begin
                                       { set single/multiple select colors }
  FPrimaryColor := Color1;
  FSecondaryColor := Color2;
                                       { presume (in case it is already attached)... }
  if HasSiblings then
    FColor := FSecondaryColor
  else
    FColor := FPrimaryColor;

end;

procedure TStretchHandle.SwitchColor;
begin
                                       { set secondary color (may be invoked by siblings) }
  FColor := FSecondaryColor;

end;

procedure TStretchHandle.SetChildControl(ChildControl: TControl);
begin

  if (ChildControl <> nil) then
    Attach(ChildControl)
  else
    Detach;

end;

function TStretchHandle.GetChildControl: TControl;
begin

  Result := FChildControl;

end;

function TStretchHandle.HasSiblings: boolean;
var
  i: integer;
begin
                                       { find out if there is at least one sibling }
  Result := False;
  for i := 0 to Parent.ControlCount - 1 do
    if (Parent.Controls[i] is TStretchHandle) and (TStretchHandle(Parent.Controls[i]) <> Self) then
      begin
        Result := True;
        break;
      end;

end;

procedure TStretchHandle.SetGridState(Value: boolean);
begin
                                       { a value of 1 effectively disables a grid axis }
  if Value then
    begin
      FGridX := 8;
      FGridY := 8;
    end
  else
    begin
      FGridX := 1;
      FGridY := 1;
    end;

end;

function TStretchHandle.GetGridState: boolean;
begin

  if (FGridX > 1) or (FGridY > 1) then
    Result := True
  else
    Result := False;

end;

function TStretchHandle.IsAttached: boolean;
begin

  if FChildControl <> nil then
    Result := True
  else
    Result := False;

end;

procedure TStretchHandle.WMGetDLGCode(var Message: TMessage);
begin
                                       { completely fake erase, don't call inherited, don't collect $200 }
  Message.Result := DLGC_WANTARROWS;

end;

procedure TStretchHandle.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
                                       { completely fake erase, don't call inherited, don't collect $200 }
  Message.Result := 1;

end;

procedure TStretchHandle.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  ARect, BRect: TRect;
  DragStyle: TDragStyle;
begin
                                       { default to move cursor unless near a drag box }
  DragStyle := dsMove;
  Cursor := DragCursor;
                                       { disallow resize if siblings present }
  if not HasSiblings then
    begin

      ARect := GetClientRect;
                                       { so I don't like long nested if statements... }
      if ((Abs(X - ARect.Left) < 5) and (Abs(Y - ARect.Top) < 5)) then
        begin
          DragStyle := dsSizeTopLeft;
          Cursor := crSizeNWSE;
        end;

      if ((Abs(X - ARect.Right) < 5) and (Abs(Y - ARect.Bottom) < 5)) then
        begin
          DragStyle := dsSizeBottomRight;
          Cursor := crSizeNWSE;
        end;

      if ((Abs(X - ARect.Right) < 5) and (Abs(Y - ARect.Top) < 5)) then
        begin
          DragStyle := dsSizeTopRight;
          Cursor := crSizeNESW;
        end;

      if ((Abs(X - ARect.Left) < 5) and (Abs(Y - ARect.Bottom) < 5)) then
        begin
          DragStyle := dsSizeBottomLeft;
          Cursor := crSizeNESW;
        end;

      if ((Abs(X - trunc(ARect.Right - ARect.Left) / 2) < 3) and (Abs(Y - ARect.Top) < 5)) then
        begin
          DragStyle := dsSizeTop;
          Cursor := crSizeNS;
        end;

      if ((Abs(X - trunc(ARect.Right - ARect.Left) / 2) < 3) and (Abs(Y - ARect.Bottom) < 5)) then
        begin
          DragStyle := dsSizeBottom;
          Cursor := crSizeNS;
        end;

      if ((Abs(Y - trunc(ARect.Bottom - ARect.Top) / 2) < 3) and (Abs(X - ARect.Left) < 5)) then
        begin
          DragStyle := dsSizeLeft;
          Cursor := crSizeWE;
        end;

      if ((Abs(Y - trunc(ARect.Bottom - ARect.Top) / 2) < 3) and (Abs(X - ARect.Right) < 5)) then
        begin
          DragStyle := dsSizeRight;
          Cursor := crSizeWE;
        end;

    end;

  if FDragging then
    begin
                                       { adjust for snap-to grid (with offset for Child's position) }
      if FGridX > 1 then
        X := (X DIV FGridX) * FGridX - 2;
      if FGridY > 1 then
        Y := (Y DIV FGridY) * FGridY - 2;
                                       { disallow drag off Parent }
      if (Left + X) < 0 then
        X := -Left;
      if (Top + Y) < 0 then
        Y := -Top;
      if (Left + X) > Parent.Width then
        X := Parent.Width - Left;
      if (Top + Y) > Parent.Height then
        Y := Parent.Height - Top;
                                       { display drag outline }
      RubberBand(GetModifiedRect(X, Y));
    end
  else
    FDragStyle := DragStyle;
                                       { if position-locked, override cursor change }
  if FLocked then
    Cursor := crNoDrop;
                                       { perform default processing }
  inherited MouseMove(Shift, X, Y);

end;

procedure TStretchHandle.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin

  if (Button = mbLeft) and not FLocked then
    begin
                                       { adjust for snap-to grid (with offset for Child's position) }
      if FGridX > 1 then
        X := (X DIV FGridX) * FGridX - 2;
      if FGridY > 1 then
        Y := (Y DIV FGridY) * FGridY - 2;
                                       { save position relative to Canvas, & which corner/side to drag }
      FDragOffset := Point(X, Y);
      FDragging := True;
      RubberBand(GetModifiedRect(X, Y));

    end;
                                       { perform default processing }
  inherited MouseDown(Button, Shift, X, Y);

end;

procedure TStretchHandle.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  ARect: TRect;
begin

  if Button = mbLeft then
    begin
                                       { adjust for snap-to grid (with offset for Child's position) }
      if FGridX > 1 then
        X := (X DIV FGridX) * FGridX - 2;
      if FGridY > 1 then
        Y := (Y DIV FGridY) * FGridY - 2;
                                       { disallow drop off Parent }
      if (Left + X) < 0 then
        X := -Left;
      if (Top + Y) < 0 then
        Y := -Top;
      if (Left + X) > Parent.Width then
        X := Parent.Width - Left;
      if (Top + Y) > Parent.Height then
        Y := Parent.Height - Top;

      if FDragging then
        begin
                                       { obtain new coordinates }
          ARect := GetModifiedRect(X, Y);
          RubberBand(Rect(0, 0, 0, 0));
                                       { force Paint when size doesn't change but position does }
          if (ARect.Left <> Left) or (ARect.Top <> Top) then
            Invalidate;
                                       { if this was a move, first move siblings }
          if FDragStyle = dsMove then
            MoveSiblings(ARect.Left - Left, ARect.Top - Top);
                                       { resize, reposition if anything changed }
          SetBounds(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);

          FDragging := False;
                                       { seem to need this for keyboard events }
          SetFocus;

        end;

        ReleaseCapture;

    end;
                                       { perform default processing }
  inherited MouseUp(Button, Shift, X, Y);

end;

procedure TStretchHandle.KeyDown(var Key: Word; Shift: TShiftState);
begin
                                       { process arrow keys to move/resize Handles & Child, also move siblings }
  case Key of
    VK_UP:
      begin
        if FChildControl <> nil then
          FChildControl.Invalidate;
        Invalidate;
        SetBounds(Left, Top - 1, Width, Height);
        MoveSiblings(0, -1);
      end;
    VK_DOWN:
      begin
        if FChildControl <> nil then
          FChildControl.Invalidate;
        Invalidate;
        SetBounds(Left, Top + 1, Width, Height);
        MoveSiblings(0, 1);
      end;
    VK_LEFT:
      begin
        if FChildControl <> nil then
          FChildControl.Invalidate;
        Invalidate;
        SetBounds(Left - 1, Top, Width, Height);
        MoveSiblings(-1, 0);
      end;
    VK_RIGHT:
      begin
        if FChildControl <> nil then
          FChildControl.Invalidate;
        Invalidate;
        SetBounds(Left + 1, Top, Width, Height);
        MoveSiblings(1, 0);
      end;
  end;

  inherited KeyDown(Key, Shift);

end;

function TStretchHandle.GetModifiedRect(XPos, YPos: integer): TRect;
var
  ARect: TRect;
begin
                                       { compute new position/size, depending on FDragStyle}
  case FDragStyle of

    dsSizeTopLeft:
      begin
        ARect.Left := Left + (XPos - FDragOffset.X);
        ARect.Top := Top + (YPos - FDragOffset.Y);
        ARect.Right := Width - (ARect.Left - Left);
        ARect.Bottom := Height - (ARect.Top - Top);
      end;

    dsSizeTopRight:
      begin
        ARect.Left := Left;
        ARect.Top := Top + (YPos - FDragOffset.Y);
        ARect.Right := Width + (XPos - FDragOffset.X);
        ARect.Bottom := Height - (ARect.Top - Top);
      end;

    dsSizeBottomLeft:
      begin
        ARect.Left := Left + (XPos - FDragOffset.X);
        ARect.Top := Top;
        ARect.Right := Width - (ARect.Left - Left);
        ARect.Bottom := Height + (YPos - FDragOffset.Y);
      end;

    dsSizeBottomRight:
      begin
        ARect.Left := Left;
        ARect.Top := Top;
        ARect.Right := Width + (XPos - FDragOffset.X);
        ARect.Bottom := Height + (YPos - FDragOffset.Y);
      end;

    dsSizeTop:
      begin
        ARect.Left := Left;
        ARect.Top := Top + (YPos - FDragOffset.Y);
        ARect.Right := Width;
        ARect.Bottom := Height - (ARect.Top - Top);
      end;

    dsSizeBottom:
      begin
        ARect.Left := Left;
        ARect.Top := Top;
        ARect.Right := Width;
        ARect.Bottom := Height + (YPos - FDragOffset.Y);
      end;

    dsSizeLeft:
      begin
        ARect.Left := Left + (XPos - FDragOffset.X);
        ARect.Top := Top;
        ARect.Right := Width - (ARect.Left - Left);
        ARect.Bottom := Height;
      end;

    dsSizeRight:
      begin
        ARect.Left := Left;
        ARect.Top := Top;
        ARect.Right := Width + (XPos - FDragOffset.X);
        ARect.Bottom := Height;
      end;

  else
                                       { keep size, move to new position }
    ARect.Left := Left + (XPos - FDragOffset.X);
    ARect.Top := Top + (YPos - FDragOffset.Y);
    ARect.Right := Width;
    ARect.Bottom := Height;

  end;
                                       { impose a minimum size for sanity }
  if ARect.Right < 5 then
    ARect.Right := 5;
  if ARect.Bottom < 5 then
    ARect.Bottom := 5;

  Result := ARect;

end;

procedure TStretchHandle.Rubberband(NewRect: TRect);
var
  PtA, PtB: TPoint;
  ScreenDC: HDC;
begin

  ScreenDC := GetDC(0);
                                       { erase previous rectangle, if any, & adjust for handle's position }
  PtA := Parent.ClientToScreen(Point(FDragRect.Left + 2, FDragRect.Top + 2));
  PtB := Parent.ClientToScreen(Point(FDragRect.Left + FDragRect.Right - 3, FDragRect.Top + FDragRect.Bottom - 3));
  if (FDragRect.Left <> 0) or (FDragRect.Top <> 0) or (FDragRect.Right <> 0) or (FDragRect.Bottom <> 0) then
    DrawFocusRect(ScreenDC, Rect(PtA.X, PtA.Y, PtB.X, PtB.Y));
                                       { draw new rectangle }
  PtA := Parent.ClientToScreen(Point(NewRect.Left + 2, NewRect.Top + 2));
  PtB := Parent.ClientToScreen(Point(NewRect.Left + NewRect.Right - 3, NewRect.Top + NewRect.Bottom - 3));
  if (NewRect.Left <> 0) or (NewRect.Top <> 0) or (NewRect.Right <> 0) or (NewRect.Bottom <> 0) then
    DrawFocusRect(ScreenDC, Rect(PtA.X, PtA.Y, PtB.X, PtB.Y));

  FDragRect := NewRect;

  ReleaseDC(0, ScreenDC);

end;

procedure TStretchHandle.BringToFront;
begin
                                       { take care of Child first }
  if FChildControl <> nil then
    FChildControl.BringToFront;
  inherited BringToFront;
  SetFocus;

end;

procedure TStretchHandle.SendToBack;
begin
                                       { only child goes to back! }
  if FChildControl <> nil then
    FChildControl.SendToBack;
  inherited BringToFront;
  SetFocus;

end;

procedure TStretchHandle.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
   WasVisible: boolean;
begin
                                       { hide & preserve fixed size in design mode }
  WasVisible := Visible;
  if csDesigning in ComponentState then
    begin
      Visible := False;
      inherited SetBounds(ALeft, ATop, 24, 24);
    end
  else                                 { move child also, if any (but only if not locked) }
    if not FLocked then
      begin
        if FChildControl <> nil then
          FChildControl.SetBounds(ALeft + 2, ATop + 2, AWidth - 5, AHeight - 5);
        inherited SetBounds(ALeft, ATop, AWidth, AHeight);
      end;
                                       { restore visibility }
  if Visible = False then
    Visible := WasVisible;

end;

procedure TStretchHandle.MoveSiblings(XOffset, YOffset: integer);
var
  i, T, L, W, H: integer;
begin
                                       { look for siblings, adjust their position by FDropOffset }
  for i := 0 to Parent.ControlCount - 1 do
    if Parent.Controls[i] is TStretchHandle then
      begin
        if (TStretchHandle(Parent.Controls[i]).Attached) and (TStretchHandle(Parent.Controls[i]) <> Self) then
          begin
            L := TStretchHandle(Parent.Controls[i]).Left + XOffset;
            T := TStretchHandle(Parent.Controls[i]).Top + YOffset;
            W := TStretchHandle(Parent.Controls[i]).Width;
            H := TStretchHandle(Parent.Controls[i]).Height;
            TStretchHandle(Parent.Controls[i]).Invalidate;
            TStretchHandle(Parent.Controls[i]).SetBounds(L, T, W, H);
          end;
      end;

end;

procedure TStretchHandle.Paint;
var
   ARect, BoxRect: TRect;
begin

  inherited Paint;

  ARect := Rect(0, 0, Width - 1, Height - 1);

  with Canvas do
    begin

      Brush.Color := FColor;
                                       { draw corner boxes (assuming Canvas is minimum 5x5) }
      BoxRect := Rect(ARect.Left, ARect.Top, ARect.Left + 5, ARect.Top + 5);
      FillRect(BoxRect);
      BoxRect := Rect(ARect.Right - 5, ARect.Top, ARect.Right, ARect.Top + 5);
      FillRect(BoxRect);
      BoxRect := Rect(ARect.Right - 5, ARect.Bottom - 5, ARect.Right, ARect.Bottom);
      FillRect(BoxRect);
      BoxRect := Rect(ARect.Left, ARect.Bottom - 5, ARect.Left + 5, ARect.Bottom);
      FillRect(BoxRect);
                                       { draw center boxes (favouring 1 pixel to the right for even sides) }
      BoxRect := Rect(trunc((ARect.Right - ARect.Left) / 2) - 2,
                      ARect.Top,
                      trunc((ARect.Right - ARect.Left) / 2) + 3,
                      ARect.Top + 5);
      FillRect(BoxRect);
      BoxRect := Rect(trunc((ARect.Right - ARect.Left) / 2) - 2,
                      ARect.Bottom - 5,
                      trunc((ARect.Right - ARect.Left) / 2) + 3,
                      ARect.Bottom);
      FillRect(BoxRect);
      BoxRect := Rect(ARect.Left,
                      trunc((ARect.Bottom - ARect.Top) / 2) - 2,
                      ARect.Left + 5,
                      trunc((ARect.Bottom - ARect.Top) / 2) + 3);
      FillRect(BoxRect);
      BoxRect := Rect(ARect.Right - 5,
                      trunc((ARect.Bottom - ARect.Top) / 2) - 2,
                      ARect.Right,
                      trunc((ARect.Bottom - ARect.Top) / 2) + 3);
      FillRect(BoxRect);

    end;

end;

end.